Index

R6 Object

library(Wu)
library(R6)
library(sloop)
library(epitools)

dt <- data.table(
  outcome = sample(c(0,1), 100, replace = TRUE)
, treatment = factor(rep(c("case", "control"), 50), levels = c("case", "control"))
, sex = factor(sample(c("F", "M"), 100, replace = TRUE), levels = c("F", "M"))
)


RR <- R6Class(
  "RR"
, list(binary = NA
     , groups = NA
     , data = NULL
     , groups_nlevels = NULL
     , tables = NULL
     , freqs = NULL
     , ors_str = NULL
     , oddsratios = NULL
     , riskratios = NULL
     , fx_or = function(x) epitools::epitab(x, method = "oddsratio", oddsratio = "wald")
     , fx_rr = function(x) epitools::epitab(x, method = "riskratio", oddsratio = "wald")
     , initialize = function(binary, groups, data) {
       self$binary <- binary
       self$groups <- groups
       vars <- c(binary, groups)
       self$data <- data[, ..vars]
       self$groups_nlevels <- lapply(groups, function(x) length(levels(self$data[[x]])))
       self$tables <- lapply(self$groups, function(x) table(self$data[[x]], self$data[[self$binary]]))
       self$freqs <- lapply(self$groups, function(x) Wu::tab_freq(self$binary, x, self$data))
       self$ors_str <- Wu::get_ors(self$binary, self$groups, self$data)
       self$oddsratios <- lapply(self$tables, self$fx_or)
       self$riskratios <- lapply(self$tables, self$fx_rr)
     }
     ))



RR1 <- RR$new(binary = "outcome", groups = c("treatment", "sex"), data = dt)




add_copy_icon <- function(id){
  txt <- paste0('<button type=\"button\" onclick=\"selectElementContents( document.getElementById('
              , '\''
              , id
              , '\''
              , ') );\">Copy Table</button>')
  cat(txt)
}

add_copy_icon("t1")

RR1$oddsratios[[2]]$tab %>%
   prt(table.attr="id=t1", caption = "Table of Odds Ratio")

library(DT)
dt <- RR1$oddsratios[[2]]$tab
dt <- as.data.frame(dt)
dt <- round(dt, 4)

datatable(dt
, extensions = 'Buttons'
, options = list(
    dom = 'Bfrtip'
  , buttons = c('copy', 'csv', 'excel', 'pdf', 'print')
  )
  , caption = "Odds Ratios"
)

Test GPU (doesn’t work)

• http://www.r-tutor.com/gpu-computing/clustering/distance-matrix
• https://github.com/cdeterman/gpuR/wiki/Build-Instructions-for-Linux

test.data <- function(dim, num, seed = 17){
  set.seed(seed)
  matrix(rnorm(dim * dim), nrow = num)
}

m <- test.data(1200, 45000)

system.time(dist(m))


# Dev RViennaCL
devtools::install_github("cdeterman/RViennaCL")

# Dev gpuR
devtools::install_github("cdeterman/gpuR")


A <- seq.int(from=0, to=999)
B <- seq.int(from=1000, to=1)
gpuA <- gpuVector(A)
gpuB <- gpuVector(B)

C <- A + B
gpuC <- gpuA + gpuB

all(C == gpuC)

Environment

sessionInfo()

R version 4.1.0 (2021-05-18) Platform: x86_64-pc-linux-gnu (64-bit) Running under: Ubuntu 20.04.2 LTS

Matrix products: default BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0 LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0

locale: [1] LC_CTYPE=C.UTF-8 LC_NUMERIC=C LC_TIME=C.UTF-8
[4] LC_COLLATE=C.UTF-8 LC_MONETARY=C.UTF-8 LC_MESSAGES=C.UTF-8
[7] LC_PAPER=C.UTF-8 LC_NAME=C LC_ADDRESS=C
[10] LC_TELEPHONE=C LC_MEASUREMENT=C.UTF-8 LC_IDENTIFICATION=C

attached base packages: [1] stats graphics grDevices utils datasets methods base

other attached packages: [1] epitools_0.5-10.1 sloop_1.0.1 R6_2.5.0
[4] Wu_0.0.0.9000 flexdashboard_0.5.2 lme4_1.1-27.1
[7] Matrix_1.3-4 mgcv_1.8-36 nlme_3.1-152
[10] png_0.1-7 scales_1.1.1 nnet_7.3-16
[13] labelled_2.8.0 kableExtra_1.3.4 plotly_4.9.4.1
[16] gridExtra_2.3 ggplot2_3.3.5 DT_0.18
[19] tableone_0.13.0 magrittr_2.0.1 lubridate_1.7.10
[22] dplyr_1.0.7 plyr_1.8.6 data.table_1.14.0
[25] rmdformats_1.0.2 knitr_1.33

loaded via a namespace (and not attached): [1] httr_1.4.2 sass_0.4.0 tidyr_1.1.3 jsonlite_1.7.2
[5] viridisLite_0.4.0 splines_4.1.0 bslib_0.2.5.1 assertthat_0.2.1 [9] highr_0.9 yaml_2.2.1 pillar_1.6.1 lattice_0.20-44
[13] glue_1.4.2 digest_0.6.27 rvest_1.0.0 minqa_1.2.4
[17] colorspace_2.0-2 htmltools_0.5.1.1 survey_4.0 pkgconfig_2.0.3
[21] haven_2.4.1 bookdown_0.22 purrr_0.3.4 webshot_0.5.2
[25] svglite_2.0.0 tibble_3.1.2 generics_0.1.0 ellipsis_0.3.2
[29] withr_2.4.2 klippy_0.0.0.9500 lazyeval_0.2.2 survival_3.2-11
[33] crayon_1.4.1 evaluate_0.14 fansi_0.5.0 MASS_7.3-54
[37] forcats_0.5.1 xml2_1.3.2 tools_4.1.0 hms_1.1.0
[41] mitools_2.4 lifecycle_1.0.0 stringr_1.4.0 munsell_0.5.0
[45] compiler_4.1.0 jquerylib_0.1.4 systemfonts_1.0.2 rlang_0.4.11
[49] grid_4.1.0 nloptr_1.2.2.2 rstudioapi_0.13 htmlwidgets_1.5.3 [53] crosstalk_1.1.1 rmarkdown_2.9 boot_1.3-28 gtable_0.3.0
[57] DBI_1.1.1 performance_0.7.2 utf8_1.2.1 insight_0.14.2
[61] stringi_1.6.2 Rcpp_1.0.7 vctrs_0.3.8 tidyselect_1.1.1 [65] xfun_0.24